home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / elhash.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-04  |  21.6 KB  |  776 lines

  1. /*
  2.  
  3. This file is part of XEmacs.
  4.  
  5. XEmacs is free software; you can redistribute it and/or modify it
  6. under the terms of the GNU General Public License as published by the
  7. Free Software Foundation; either version 2, or (at your option) any
  8. later version.
  9.  
  10. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  11. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  13. for more details.
  14.  
  15. You should have received a copy of the GNU General Public License
  16. along with XEmacs; see the file COPYING.  If not, write to the Free
  17. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  18.  
  19. /* Synched up with: Not in FSF. */
  20.  
  21. #include <config.h>
  22. #include "lisp.h"
  23. #include "hash.h"
  24. #include "elhash.h"
  25. #include "bytecode.h"
  26.  
  27. Lisp_Object Qhashtablep;
  28.  
  29. #define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */
  30.  
  31. struct hashtable_struct
  32. {
  33.   struct lcrecord_header header;
  34.   unsigned int fullness;
  35.   unsigned long (*hash_function) (CONST void *);
  36.   int        (*test_function) (CONST void *, CONST void *);
  37.   Lisp_Object zero_entry;
  38.   Lisp_Object harray;
  39.   enum hashtable_type type; /* whether and how this hashtable is weak */
  40.   Lisp_Object next_weak;    /* Used to chain together all of the weak
  41.                    hashtables.  Don't mark through this. */
  42. };
  43.  
  44. static Lisp_Object Vweak_hash_tables;
  45.  
  46. DECLARE_LRECORD (hashtable, struct hashtable_struct);
  47. #define XHASHTABLE(x) XRECORD (x, hashtable, struct hashtable_struct)
  48. #define XSETHASHTABLE(x, p) XSETRECORD (x, p, hashtable)
  49. #define HASHTABLEP(x) RECORDP (x, hashtable)
  50. #define CHECK_HASHTABLE(x, i) CHECK_RECORD (x, hashtable)
  51.  
  52. static Lisp_Object mark_hashtable (Lisp_Object, void (*) (Lisp_Object));
  53. static void print_hashtable (Lisp_Object, Lisp_Object, int);
  54. DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable,
  55.                                mark_hashtable, print_hashtable, 0, 0, 0,
  56.                    struct hashtable_struct);
  57.  
  58. static Lisp_Object
  59. mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object))
  60. {
  61.   struct hashtable_struct *table = XHASHTABLE (obj);
  62.  
  63.   if (table->type != HASHTABLE_NONWEAK)
  64.     {
  65.       /* If the table is weak, we don't want to mark the keys and values
  66.      (we scan over them after everything else has been marked,
  67.      and mark or remove them as necessary).     Note that we will mark
  68.      the table->harray itself at the same time; it's hard to mark
  69.      that here without also marking its contents. */
  70.       return Qnil;
  71.     }
  72.   ((markobj) (table->zero_entry));
  73.   return (table->harray);
  74. }
  75.   
  76. static void
  77. print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  78. {
  79.   struct hashtable_struct *table = XHASHTABLE (obj);
  80.   char buf[200];
  81.   if (print_readably)
  82.     error ("printing unreadable object #<hashtable 0x%x>",
  83.        table->header.uid);
  84.   sprintf (buf, GETTEXT ("#<%shashtable %d/%ld 0x%x>"),
  85.        (table->type == HASHTABLE_WEAK ? "weak " :
  86.         table->type == HASHTABLE_KEY_WEAK ? "key-weak " :
  87.         table->type == HASHTABLE_VALUE_WEAK ? "value-weak " :
  88.         ""),
  89.            table->fullness,
  90.            (vector_length (XVECTOR (table->harray)) / LISP_OBJECTS_PER_HENTRY),
  91.            table->header.uid);
  92.   write_c_string (buf, printcharfun);
  93. }
  94.  
  95. static void
  96. ht_copy_to_c (struct hashtable_struct *ht,
  97.               c_hashtable c_table)
  98. {
  99.   int len;
  100.  
  101.   c_table->harray = (void *) vector_data (XVECTOR (ht->harray));
  102.   c_table->zero_set = (!EQ (ht->zero_entry, Qunbound));
  103.   c_table->zero_entry = LISP_TO_VOID (ht->zero_entry);
  104.   len = vector_length (XVECTOR (ht->harray));
  105.   if (len < 0)
  106.     {
  107.       /* #### if alloc.c mark_object() changes, this must change too. */
  108.       /* barf gag retch.  When a vector is marked, its len is
  109.      made less than 0.  In the prune_weak_hashtables() stage,
  110.      we are called on vectors that are like this, and we must
  111.      be able to deal. */
  112.       assert (gc_in_progress);
  113.       len = -1 - len;
  114.     }
  115.   c_table->size = len/LISP_OBJECTS_PER_HENTRY;
  116.   c_table->fullness = ht->fullness;
  117.   c_table->hash_function = ht->hash_function;
  118.   c_table->test_function = ht->test_function;
  119.   XSETHASHTABLE (c_table->elisp_table, ht);
  120. }
  121.  
  122. static void
  123. ht_copy_from_c (c_hashtable c_table, 
  124.                 struct hashtable_struct *ht)
  125. {
  126.   struct Lisp_Vector dummy;
  127.   /* C is truly hateful */
  128.   void *vec_addr
  129.     = ((char *) c_table->harray 
  130.        - ((char *) &(dummy.contents) - (char *) &dummy));
  131.  
  132.   XSETVECTOR (ht->harray, vec_addr);
  133.   if (c_table->zero_set)
  134.     VOID_TO_LISP (ht->zero_entry, c_table->zero_entry);
  135.   else
  136.     ht->zero_entry = Qunbound;
  137.   ht->fullness = c_table->fullness;
  138. }
  139.  
  140.  
  141. static struct hashtable_struct *
  142. new_hashtable (void)
  143. {
  144.   struct hashtable_struct *table
  145.     = alloc_lcrecord (sizeof (struct hashtable_struct), lrecord_hashtable);
  146.   table->harray = Qnil;
  147.   table->zero_entry = Qunbound;
  148.   table->fullness = 0;
  149.   table->hash_function = 0;
  150.   table->test_function = 0;
  151.   return (table);
  152. }
  153.  
  154. char *
  155. elisp_hvector_malloc (unsigned int bytes, Lisp_Object table)
  156. {
  157.   Lisp_Object new_vector;
  158.   struct hashtable_struct *ht;
  159.  
  160.   ht = XHASHTABLE (table);
  161.   assert (bytes > vector_length (XVECTOR (ht->harray)) * sizeof (Lisp_Object));
  162.   new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qzero);
  163.   return ((char *) (vector_data (XVECTOR (new_vector))));
  164. }
  165.  
  166. void
  167. elisp_hvector_free (void *ptr, Lisp_Object table)
  168. {
  169.   struct hashtable_struct *ht = XHASHTABLE (table);
  170. #if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS)
  171.   Lisp_Object current_vector = ht->harray;
  172. #endif
  173.  
  174.   assert (((void *) vector_data (XVECTOR (current_vector))) == ptr);
  175.   ht->harray = Qnil;            /* Let GC do its job */
  176.   return;
  177. }
  178.  
  179.  
  180. DEFUN ("hashtablep", Fhashtablep, Shashtablep, 1, 1, 0,
  181.        "Return t if OBJ is a hashtable, else nil.")
  182.   (obj)
  183.   Lisp_Object obj;
  184. {
  185.   return ((HASHTABLEP (obj)) ? Qt : Qnil);
  186. }
  187.  
  188. /* C code can specify test and hash function for hash tables of lisp objects
  189.    (including weak tables) but lisp code can only create EQ tables because we
  190.    don't have a general lisp object hash function.
  191.  */
  192. Lisp_Object
  193. make_lisp_hashtable (int size,
  194.              int (*test_function) (CONST void*, CONST void*),
  195.              unsigned long (*hash_function) (CONST void*),
  196.              enum hashtable_type type)
  197. {
  198.   Lisp_Object result;
  199.   struct hashtable_struct *table = new_hashtable ();
  200.   table->harray = make_vector ((compute_harray_size (size)
  201.                 * LISP_OBJECTS_PER_HENTRY),
  202.                                Qzero);
  203.   table->test_function = test_function;
  204.   table->hash_function = hash_function;
  205.   table->type = type;
  206.   XSETHASHTABLE (result, table);
  207.  
  208.   if (table->type != HASHTABLE_NONWEAK)
  209.     {
  210.       table->next_weak = Vweak_hash_tables;
  211.       Vweak_hash_tables = result;
  212.     }
  213.   else
  214.     table->next_weak = Qunbound;
  215.  
  216.   return (result);
  217. }
  218.  
  219. DEFUN ("make-hashtable", Fmake_hashtable, Smake_hashtable, 1, 1, 0,
  220.        "Make a hashtable of initial size SIZE.")
  221.   (size)
  222.   Lisp_Object size;
  223. {
  224.   CHECK_NATNUM (size, 0);
  225.   return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_NONWEAK);
  226. }
  227.  
  228. DEFUN ("copy-hashtable", Fcopy_hashtable, Scopy_hashtable, 1, 1, 0,
  229.        "Make a new hashtable which contains the same keys and values\n\
  230. as the given table.  The keys and values will not themselves be copied.")
  231.   (old_table)
  232.   Lisp_Object old_table;
  233. {
  234.   struct _C_hashtable old_htbl;
  235.   struct _C_hashtable new_htbl;
  236.   struct hashtable_struct *old_ht;
  237.   struct hashtable_struct *new_ht;
  238.   Lisp_Object result;
  239.  
  240.   CHECK_HASHTABLE (old_table, 0);
  241.   old_ht = XHASHTABLE (old_table);
  242.   ht_copy_to_c (old_ht, &old_htbl);
  243.  
  244.   /* we can't just call Fmake_hashtable() here because that will make a
  245.      table that is slightly larger than the one we're trying to copy,
  246.      which will make copy_hash() blow up. */
  247.   new_ht = new_hashtable ();
  248.   new_ht->fullness = 0;
  249.   new_ht->zero_entry = Qunbound;
  250.   new_ht->hash_function = old_ht->hash_function;
  251.   new_ht->test_function = old_ht->test_function;
  252.   new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qzero);
  253.   ht_copy_to_c (new_ht, &new_htbl);
  254.   copy_hash (&new_htbl, &old_htbl);
  255.   ht_copy_from_c (&new_htbl, new_ht);
  256.   new_ht->type = old_ht->type;
  257.   XSETHASHTABLE (result, new_ht);
  258.  
  259.   if (EQ (old_ht->next_weak, Qunbound))
  260.     new_ht->next_weak = Qunbound;
  261.   else
  262.     {
  263.       new_ht->next_weak = Vweak_hash_tables;
  264.       Vweak_hash_tables = result;
  265.     }
  266.  
  267.   return (result);
  268. }
  269.  
  270.  
  271. DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
  272.        "Find hash value for KEY in TABLE.\n\
  273. If there is no corresponding value, return DEFAULT (defaults to nil).")
  274.   (key, table, defalt)
  275.   Lisp_Object key, table, defalt; /* One can't even spell correctly in C */
  276. {
  277.   CONST void *vval;
  278.   struct _C_hashtable htbl;
  279.   if (!gc_in_progress)
  280.     CHECK_HASHTABLE (table, 0);
  281.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  282.   if (gethash (LISP_TO_VOID (key), &htbl, &vval))
  283.     {
  284.       Lisp_Object val;
  285.       CVOID_TO_LISP (val, vval);
  286.       return val;
  287.     }
  288.   else 
  289.     return defalt;
  290. }
  291.  
  292.  
  293. DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
  294.        "Remove hash value for KEY in TABLE.")
  295.   (key, table)
  296.   Lisp_Object key, table;
  297. {
  298.   struct _C_hashtable htbl;
  299.   CHECK_HASHTABLE (table, 0);
  300.  
  301.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  302.   remhash (LISP_TO_VOID (key), &htbl);
  303.   ht_copy_from_c (&htbl, XHASHTABLE (table));
  304.   return Qnil;
  305. }
  306.  
  307.  
  308. DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
  309.        "Hash KEY to VAL in TABLE.")
  310.   (key, val, table)
  311.   Lisp_Object key, val, table;
  312. {
  313.   struct hashtable_struct *ht;
  314.   void *vkey = LISP_TO_VOID (key);
  315.  
  316.   CHECK_HASHTABLE (table, 0);
  317.   ht = XHASHTABLE (table);
  318.   if (!vkey)
  319.     ht->zero_entry = val;
  320.   else
  321.     {
  322.       struct gcpro gcpro1, gcpro2, gcpro3;
  323.       struct _C_hashtable htbl;
  324.  
  325.       ht_copy_to_c (XHASHTABLE (table), &htbl);
  326.       GCPRO3 (key, val, table);
  327.       puthash (vkey, LISP_TO_VOID (val), &htbl);
  328.       ht_copy_from_c (&htbl, XHASHTABLE (table));
  329.       UNGCPRO;
  330.     }
  331.   return (val);
  332. }
  333.  
  334. DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
  335.        "Flush TABLE.")
  336.   (table)
  337.   Lisp_Object table;
  338. {
  339.   struct _C_hashtable htbl;
  340.   CHECK_HASHTABLE (table, 0);
  341.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  342.   clrhash (&htbl);
  343.   ht_copy_from_c (&htbl, XHASHTABLE (table));
  344.   return Qnil;
  345. }
  346.  
  347. DEFUN ("hashtable-fullness", Fhashtable_fullness, Shashtable_fullness, 1, 1, 0,
  348.        "Return number of entries in TABLE.")
  349.   (table)
  350.   Lisp_Object table;
  351. {
  352.   struct _C_hashtable htbl;
  353.   CHECK_HASHTABLE (table, 0);
  354.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  355.   return (make_number (htbl.fullness));
  356. }
  357.  
  358.  
  359. static void
  360. verify_function (Lisp_Object function, char *description)
  361. {
  362.   if (SYMBOLP (function))
  363.   {
  364.     if (NILP (function))
  365.       return;
  366.     else
  367.       function = indirect_function (function, 1);
  368.   }
  369.   if (SUBRP (function) || BYTECODEP (function))
  370.     return;
  371.   else if (CONSP (function))
  372.   {
  373.     Lisp_Object funcar = Fcar (function);
  374.     if ((SYMBOLP (funcar)) 
  375.         && (EQ (funcar, Qlambda) 
  376. #ifdef MOCKLISP_SUPPORT
  377.             || EQ (funcar, Qmocklisp) 
  378. #endif
  379.             || EQ (funcar, Qautoload)))
  380.       return;
  381.   }
  382.   signal_error (Qinvalid_function, list1 (function));
  383. }
  384.  
  385. static void
  386. lisp_maphash_function (CONST void *void_key,
  387.                void *void_val,
  388.                void *void_fn)
  389. {
  390.   /* This function can GC */
  391.   Lisp_Object key, val, fn;
  392.   CVOID_TO_LISP (key, void_key);
  393.   VOID_TO_LISP (val, void_val);
  394.   VOID_TO_LISP (fn, void_fn);
  395.   call2 (fn, key, val);
  396. }
  397.  
  398.  
  399. DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
  400.        "Map FUNCTION over entries in TABLE, calling it with two args,\n\
  401. each key and value in the table.")
  402.   (function, table)
  403.   Lisp_Object function, table;
  404. {
  405.   struct _C_hashtable htbl;
  406.   struct gcpro gcpro1, gcpro2;
  407.  
  408.   verify_function (function, GETTEXT ("hashtable mapping function"));
  409.   CHECK_HASHTABLE (table, 0);
  410.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  411.   GCPRO2 (table, function);
  412.   maphash (lisp_maphash_function, &htbl, LISP_TO_VOID (function));
  413.   UNGCPRO;
  414.   return Qnil;
  415. }
  416.  
  417.  
  418. /* This function is for mapping a *C* function over the elements of a
  419.    lisp hashtable.
  420.  */
  421. void
  422. elisp_maphash (maphash_function function, Lisp_Object table, void *closure)
  423. {
  424.   struct _C_hashtable htbl;
  425.  
  426.   if (!gc_in_progress) CHECK_HASHTABLE (table, 0);
  427.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  428.   maphash (function, &htbl, closure);
  429. }
  430.  
  431. void
  432. elisp_map_remhash (remhash_predicate function,
  433.                    Lisp_Object table,
  434.                    void *closure)
  435. {
  436.   struct _C_hashtable htbl;
  437.  
  438.   if (!gc_in_progress) CHECK_HASHTABLE (table, 0);
  439.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  440.   map_remhash (function, &htbl, closure);
  441.   ht_copy_from_c (&htbl, XHASHTABLE (table));
  442. }
  443.  
  444. #if 0
  445. void
  446. elisp_table_op (Lisp_Object table, generic_hashtable_op op, void *arg1,
  447.         void *arg2, void *arg3)
  448. {
  449.   struct _C_hashtable htbl;
  450.   CHECK_HASHTABLE (table, 0);
  451.   ht_copy_to_c (XHASHTABLE (table), &htbl);
  452.   (*op) (&htbl, arg1, arg2, arg3);
  453.   ht_copy_from_c (&htbl, XHASHTABLE (table));
  454. }
  455. #endif /* 0 */
  456.  
  457.  
  458.  
  459. DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, Smake_weak_hashtable,
  460.        1, 1, 0,
  461.        "Make a fully weak hashtable of initial size SIZE.\n\
  462. A weak hashtable is one whose pointers do not count as GC referents:\n\
  463. for any key-value pair in the hashtable, if the only remaining pointer\n\
  464. to either the key or the value is in a weak hash table, then the pair\n\
  465. will be removed from the table, and the key and value collected.  A\n\
  466. non-weak hash table (or any other pointer) would prevent the object\n\
  467. from being collected.\n\
  468. \n\
  469. You can also create semi-weak hashtables; see `make-key-weak-hashtable'\n\
  470. and `make-value-weak-hashtable'.")
  471.   (size)
  472.   Lisp_Object size;
  473. {
  474.   CHECK_NATNUM (size, 0);
  475.   return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_WEAK);
  476. }
  477.  
  478. DEFUN ("make-key-weak-hashtable", Fmake_key_weak_hashtable,
  479.        Smake_key_weak_hashtable, 1, 1, 0,
  480.        "Make a key-weak hashtable of initial size SIZE.\n\
  481. A key-weak hashtable is similar to a fully-weak hashtable (see\n\
  482. `make-weak-hashtable') except that a key-value pair will be removed\n\
  483. only if the key remains unmarked outside of weak hashtables.  The pair\n\
  484. will remain in the hashtable if the key is pointed to by something other\n\
  485. than a weak hashtable, even if the value is not.")
  486.   (size)
  487.   Lisp_Object size;
  488. {
  489.   CHECK_NATNUM (size, 0);
  490.   return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_KEY_WEAK);
  491. }
  492.  
  493. DEFUN ("make-value-weak-hashtable", Fmake_value_weak_hashtable,
  494.        Smake_value_weak_hashtable, 1, 1, 0,
  495.        "Make a value-weak hashtable of initial size SIZE.\n\
  496. A value-weak hashtable is similar to a fully-weak hashtable (see\n\
  497. `make-weak-hashtable') except that a key-value pair will be removed only\n\
  498. if the value remains unmarked outside of weak hashtables.  The pair will\n\
  499. remain in the hashtable if the value is pointed to by something other\n\
  500. than a weak hashtable, even if the key is not.")
  501.   (size)
  502.   Lisp_Object size;
  503. {
  504.   CHECK_NATNUM (size, 0);
  505.   return make_lisp_hashtable (XINT (size), 0, 0, HASHTABLE_VALUE_WEAK);
  506. }
  507.  
  508. struct marking_closure
  509. {
  510.   int (*obj_marked_p) (Lisp_Object);
  511.   void (*markobj) (Lisp_Object);
  512.   enum hashtable_type type;
  513.   int did_mark;
  514. };
  515.  
  516. static void
  517. marking_mapper (CONST void *key, void *contents, void *closure)
  518. {
  519.   Lisp_Object keytem, valuetem;
  520.   struct marking_closure *fmh =
  521.     (struct marking_closure *) closure;
  522.  
  523.   /* This function is called over each pair in the hashtable.
  524.      We complete the marking for semi-weak hashtables. */
  525.   CVOID_TO_LISP (keytem, key);
  526.   CVOID_TO_LISP (valuetem, contents);
  527.   
  528.   switch (fmh->type)
  529.     {
  530.     case HASHTABLE_KEY_WEAK:
  531.       if ((fmh->obj_marked_p) (keytem) &&
  532.       !(fmh->obj_marked_p) (valuetem))
  533.     {
  534.       (fmh->markobj) (valuetem);
  535.       fmh->did_mark = 1;
  536.     }
  537.       break;
  538.  
  539.     case HASHTABLE_VALUE_WEAK:
  540.       if ((fmh->obj_marked_p) (valuetem) &&
  541.       !(fmh->obj_marked_p) (keytem))
  542.     {
  543.       (fmh->markobj) (keytem);
  544.       fmh->did_mark = 1;
  545.     }
  546.       break;
  547.  
  548.     default:
  549.       abort (); /* Huh? */
  550.     }
  551.       
  552.   return;
  553. }
  554.  
  555. int
  556. finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object),
  557.                 void (*markobj) (Lisp_Object))
  558. {
  559.   Lisp_Object rest;
  560.   int did_mark = 0;
  561.  
  562.   for (rest = Vweak_hash_tables;
  563.        !NILP (rest);
  564.        rest = XHASHTABLE (rest)->next_weak)
  565.     {
  566.       enum hashtable_type type;
  567.  
  568.       if (! ((*obj_marked_p) (rest)))
  569.     /* The hashtable is probably garbage.  Ignore it. */
  570.     continue;
  571.       type = XHASHTABLE (rest)->type;
  572.       if (type == HASHTABLE_KEY_WEAK || type == HASHTABLE_VALUE_WEAK)
  573.     {
  574.           struct marking_closure fmh;
  575.  
  576.           fmh.obj_marked_p = obj_marked_p;
  577.       fmh.markobj = markobj;
  578.       fmh.type = type;
  579.       fmh.did_mark = 0;
  580.       /* Now, scan over all the pairs.  For all pairs that are
  581.          half-marked, we may need to mark the other half if we're
  582.          keeping this pair. */
  583.       elisp_maphash (marking_mapper, rest, &fmh);
  584.       if (fmh.did_mark)
  585.         did_mark = 1;
  586.     }
  587.  
  588.       /* #### If alloc.c mark_object changes, this must change also... */
  589.       {
  590.     /* Now mark the vector itself.  (We don't need to call markobj
  591.        here because we know that everything *in* it is already marked,
  592.        we just need to prevent the vector itself from disappearing.)
  593.        (The remhash above has taken care of zero_entry.)
  594.        */
  595.     struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray);
  596.     int len = vector_length (ptr);
  597.     if (len >= 0)
  598.       {
  599.         ptr->size = -1 - len;
  600.         did_mark = 1;
  601.       }
  602.     /* else it's already marked (remember, this function is iterated
  603.        until marking stops) */
  604.       }
  605.     }
  606.  
  607.   return did_mark;
  608. }
  609.  
  610. struct pruning_closure
  611. {
  612.   int (*obj_marked_p) (Lisp_Object);
  613. };
  614.  
  615. static int
  616. pruning_mapper (CONST void *key, CONST void *contents, void *closure)
  617. {
  618.   Lisp_Object keytem, valuetem;
  619.   struct pruning_closure *fmh =
  620.     (struct pruning_closure *) closure;
  621.  
  622.   /* This function is called over each pair in the hashtable.
  623.      We remove the pairs that aren't completely marked (everything
  624.      that is going to stay ought to have been marked already
  625.      by the finish_marking stage). */
  626.   CVOID_TO_LISP (keytem, key);
  627.   CVOID_TO_LISP (valuetem, contents);
  628.  
  629.   return (! ((*fmh->obj_marked_p) (keytem) &&
  630.          (*fmh->obj_marked_p) (valuetem)));
  631. }
  632.  
  633. void
  634. prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object))
  635. {
  636.   Lisp_Object rest, prev = Qnil;
  637.   for (rest = Vweak_hash_tables;
  638.        !NILP (rest);
  639.        rest = XHASHTABLE (rest)->next_weak)
  640.     {
  641.       if (! ((*obj_marked_p) (rest)))
  642.     {
  643.       /* This table itself is garbage.  Remove it from the list. */
  644.       if (NILP (prev))
  645.         Vweak_hash_tables = XHASHTABLE (rest)->next_weak;
  646.       else
  647.         XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak;
  648.     }
  649.       else
  650.     {
  651.           struct pruning_closure fmh;
  652.           fmh.obj_marked_p = obj_marked_p;
  653.       /* Now, scan over all the pairs.  Remove all of the pairs
  654.          in which the key or value, or both, is unmarked
  655.          (depending on the type of weak hashtable). */
  656.       elisp_map_remhash (pruning_mapper, rest, &fmh);
  657.       prev = rest;
  658.     }
  659.     }
  660. }
  661.  
  662.  
  663.  
  664. /* equality and hash functions for Lisp strings */
  665. int
  666. lisp_string_equal (CONST void *x1, CONST void *x2)
  667. {
  668.   Lisp_Object str1, str2;
  669.   CVOID_TO_LISP (str1, x1);
  670.   CVOID_TO_LISP (str2, x2);
  671.   return !strcmp ((char *) string_data (XSTRING (str1)),
  672.           (char *) string_data (XSTRING (str2))); 
  673. }
  674.  
  675. unsigned long
  676. lisp_string_hash (CONST void *x)
  677. {
  678.   Lisp_Object str;
  679.   CVOID_TO_LISP (str, x);
  680.   return hash_string (string_data (XSTRING (str)),
  681.               string_length (XSTRING (str)));
  682. }
  683.  
  684. /* Return a hash value for a Lisp_Object.  This is for use when hashing
  685.    objects with the comparison being `equal' (for `eq', you can just
  686.    use the Lisp_Object itself as the hash value).  You need to make a
  687.    tradeoff between the speed of the hash function and how good the
  688.    hashing is.  In particular, the hash function needs to be FAST,
  689.    so you can't just traipse down the whole tree hashing everything
  690.    together.  Most of the time, objects will differ in the first
  691.    few elements you hash.  Thus, we only go to a short depth (5)
  692.    and only hash at most 5 elements out of a vector.  Theoretically
  693.    we could still take 5^5 time (a big big number) to compute a
  694.    hash, but practically this won't ever happen. */
  695.  
  696. unsigned long
  697. internal_hash (Lisp_Object obj, int depth)
  698. {
  699.   if (depth > 5)
  700.     return 0;
  701.   if (CONSP (obj))
  702.     {
  703.       /* no point in worrying about tail recursion, since we're not
  704.      going very deep */
  705.       return HASH2 (internal_hash (XCAR (obj), depth + 1),
  706.             internal_hash (XCDR (obj), depth + 1));
  707.     }
  708. #ifndef LRECORD_VECTOR
  709.   else if (VECTORP (obj))
  710.     {
  711.       int i;
  712.       struct Lisp_Vector *v = XVECTOR (obj);
  713.       int len = vector_length (v);
  714.       unsigned long hash = 0;
  715.  
  716.       if (len <= 5)
  717.     {
  718.       for (i = 0; i < len; i++)
  719.         hash = HASH2 (hash, internal_hash (v->contents[i], depth + 1));
  720.       return hash;
  721.     }
  722.  
  723.       /* just pick five elements scattered throughout the vector.
  724.      A slightly better approach would be to offset by some
  725.      noise factor from the points chosen below. */
  726.       for (i = 0; i < 5; i++)
  727.     hash = HASH2 (hash, internal_hash (v->contents[i*len/5], depth + 1));
  728.  
  729.       return hash;
  730.     }
  731. #endif /* !LRECORD_VECTOR */
  732.   else if (STRINGP (obj))
  733.     return hash_string (string_data (XSTRING (obj)),
  734.             string_length (XSTRING (obj)));
  735.   else if (LRECORDP (obj))
  736.     {
  737.       CONST struct lrecord_implementation
  738.     *imp = XRECORD_LHEADER (obj)->implementation;
  739.       if (imp->hash)
  740.     return ((imp->hash) (obj, depth));
  741.     }
  742.  
  743.   return LISP_HASH (obj);
  744. }
  745.  
  746.  
  747. /************************************************************************/
  748. /*                            initialization                            */
  749. /************************************************************************/
  750.  
  751. void
  752. syms_of_elhash (void)
  753. {
  754.   defsubr (&Smake_hashtable);
  755.   defsubr (&Scopy_hashtable);
  756.   defsubr (&Shashtablep);
  757.   defsubr (&Sgethash);
  758.   defsubr (&Sputhash);
  759.   defsubr (&Sremhash);
  760.   defsubr (&Sclrhash);
  761.   defsubr (&Smaphash);
  762.   defsubr (&Shashtable_fullness);
  763.   defsubr (&Smake_weak_hashtable);
  764.   defsubr (&Smake_key_weak_hashtable);
  765.   defsubr (&Smake_value_weak_hashtable);
  766.   defsymbol (&Qhashtablep, "hashtablep");
  767. }
  768.  
  769. void
  770. vars_of_elhash (void)
  771. {
  772.   /* This must not be staticpro'd */
  773.   Vweak_hash_tables = Qnil;
  774. }
  775.  
  776.